home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xllist.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  20.4 KB  |  955 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xllist.c
  5. * RCS:          $Header: xllist.c,v 1.4 91/03/24 22:25:09 mayer Exp $
  6. * Description:  xlisp built-in list functions
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 04:05:52 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xllist.c,v 1.4 91/03/24 22:25:09 mayer Exp $";
  43.  
  44.  
  45. #include "xlisp.h"
  46.  
  47. /* forward declarations */
  48. LOCAL FORWARD LVAL cxr();    /* NPM: changed this to LOCAL */
  49. LOCAL FORWARD LVAL nth(),assoc(); /* NPM: changed this to LOCAL */
  50. LOCAL FORWARD LVAL subst(),sublis(),map(); /* NPM: changed this to LOCAL */
  51.  
  52. /* xcar - take the car of a cons cell */
  53. LVAL xcar()
  54. {
  55.     LVAL list;
  56.     list = xlgalist();
  57.     xllastarg();
  58.     return (list ? car(list) : NIL);
  59. }
  60.  
  61. /* xcdr - take the cdr of a cons cell */
  62. LVAL xcdr()
  63. {
  64.     LVAL list;
  65.     list = xlgalist();
  66.     xllastarg();
  67.     return (list ? cdr(list) : NIL);
  68. }
  69.  
  70. /* cxxr functions */
  71. LVAL xcaar() { return (cxr("aa")); }
  72. LVAL xcadr() { return (cxr("da")); }
  73. LVAL xcdar() { return (cxr("ad")); }
  74. LVAL xcddr() { return (cxr("dd")); }
  75.  
  76. /* cxxxr functions */
  77. LVAL xcaaar() { return (cxr("aaa")); }
  78. LVAL xcaadr() { return (cxr("daa")); }
  79. LVAL xcadar() { return (cxr("ada")); }
  80. LVAL xcaddr() { return (cxr("dda")); }
  81. LVAL xcdaar() { return (cxr("aad")); }
  82. LVAL xcdadr() { return (cxr("dad")); }
  83. LVAL xcddar() { return (cxr("add")); }
  84. LVAL xcdddr() { return (cxr("ddd")); }
  85.  
  86. /* cxxxxr functions */
  87. LVAL xcaaaar() { return (cxr("aaaa")); }
  88. LVAL xcaaadr() { return (cxr("daaa")); }
  89. LVAL xcaadar() { return (cxr("adaa")); }
  90. LVAL xcaaddr() { return (cxr("ddaa")); }
  91. LVAL xcadaar() { return (cxr("aada")); }
  92. LVAL xcadadr() { return (cxr("dada")); }
  93. LVAL xcaddar() { return (cxr("adda")); }
  94. LVAL xcadddr() { return (cxr("ddda")); }
  95. LVAL xcdaaar() { return (cxr("aaad")); }
  96. LVAL xcdaadr() { return (cxr("daad")); }
  97. LVAL xcdadar() { return (cxr("adad")); }
  98. LVAL xcdaddr() { return (cxr("ddad")); }
  99. LVAL xcddaar() { return (cxr("aadd")); }
  100. LVAL xcddadr() { return (cxr("dadd")); }
  101. LVAL xcdddar() { return (cxr("addd")); }
  102. LVAL xcddddr() { return (cxr("dddd")); }
  103.  
  104. /* cxr - common car/cdr routine */
  105. LOCAL LVAL cxr(adstr)
  106.   char *adstr;
  107. {
  108.     LVAL list;
  109.  
  110.     /* get the list */
  111.     list = xlgalist();
  112.     xllastarg();
  113.  
  114.     /* perform the car/cdr operations */
  115.     while (*adstr && consp(list))
  116.     list = (*adstr++ == 'a' ? car(list) : cdr(list));
  117.  
  118.     /* make sure the operation succeeded */
  119.     if (*adstr && list)
  120.     xlfail("bad argument");
  121.  
  122.     /* return the result */
  123.     return (list);
  124. }
  125.  
  126. /* xcons - construct a new list cell */
  127. LVAL xcons()
  128. {
  129.     LVAL arg1,arg2;
  130.  
  131.     /* get the two arguments */
  132.     arg1 = xlgetarg();
  133.     arg2 = xlgetarg();
  134.     xllastarg();
  135.  
  136.     /* construct a new list element */
  137.     return (cons(arg1,arg2));
  138. }
  139.  
  140. /* xlist - built a list of the arguments */
  141. LVAL xlist()
  142. {
  143.     LVAL last,next,val;
  144.  
  145.     /* protect some pointers */
  146.     xlsave1(val);
  147.  
  148.     /* add each argument to the list */
  149.     for (val = NIL; moreargs(); ) {
  150.  
  151.     /* append this argument to the end of the list */
  152.     next = consa(nextarg());
  153.     if (val) rplacd(last,next);
  154.     else val = next;
  155.     last = next;
  156.     }
  157.  
  158.     /* restore the stack */
  159.     xlpop();
  160.  
  161.     /* return the list */
  162.     return (val);
  163. }
  164.  
  165. /* xappend - built-in function append */
  166. LVAL xappend()
  167. {
  168.     LVAL list,last,next,val;
  169.  
  170.     /* protect some pointers */
  171.     xlsave1(val);
  172.  
  173.     /* initialize */
  174.     val = NIL;
  175.     
  176.     /* append each argument */
  177.     if (moreargs()) {
  178.     while (xlargc > 1) {
  179.  
  180.         /* append each element of this list to the result list */
  181.         for (list = nextarg(); consp(list); list = cdr(list)) {
  182.         next = consa(car(list));
  183.         if (val) rplacd(last,next);
  184.         else val = next;
  185.         last = next;
  186.         }
  187.     }
  188.  
  189.     /* handle the last argument */
  190.     if (val) rplacd(last,nextarg());
  191.     else val = nextarg();
  192.     }
  193.  
  194.     /* restore the stack */
  195.     xlpop();
  196.  
  197.     /* return the list */
  198.     return (val);
  199. }
  200.  
  201. /* xreverse - built-in function reverse */
  202. LVAL xreverse()
  203. {
  204.     LVAL list,val;
  205.  
  206.     /* protect some pointers */
  207.     xlsave1(val);
  208.  
  209.     /* get the list to reverse */
  210.     list = xlgalist();
  211.     xllastarg();
  212.  
  213.     /* append each element to the head of the result list */
  214.     for (val = NIL; consp(list); list = cdr(list))
  215.     val = cons(car(list),val);
  216.  
  217.     /* restore the stack */
  218.     xlpop();
  219.  
  220.     /* return the list */
  221.     return (val);
  222. }
  223.  
  224. /* xlast - return the last cons of a list */
  225. LVAL xlast()
  226. {
  227.     LVAL list;
  228.  
  229.     /* get the list */
  230.     list = xlgalist();
  231.     xllastarg();
  232.  
  233.     /* find the last cons */
  234.     while (consp(list) && cdr(list))
  235.     list = cdr(list);
  236.  
  237.     /* return the last element */
  238.     return (list);
  239. }
  240.  
  241. /* xmember - built-in function 'member' */
  242. LVAL xmember()
  243. {
  244.     LVAL x,list,fcn,val;
  245.     int tresult;
  246.  
  247.     /* protect some pointers */
  248.     xlsave1(fcn);
  249.  
  250.     /* get the expression to look for and the list */
  251.     x = xlgetarg();
  252.     list = xlgalist();
  253.     xltest(&fcn,&tresult);
  254.  
  255.     /* look for the expression */
  256.     for (val = NIL; consp(list); list = cdr(list))
  257.     if (dotest2(x,car(list),fcn) == tresult) {
  258.         val = list;
  259.         break;
  260.     }
  261.  
  262.     /* restore the stack */
  263.     xlpop();
  264.  
  265.     /* return the result */
  266.     return (val);
  267. }
  268.  
  269. /* xassoc - built-in function 'assoc' */
  270. LVAL xassoc()
  271. {
  272.     LVAL x,alist,fcn,pair,val;
  273.     int tresult;
  274.  
  275.     /* protect some pointers */
  276.     xlsave1(fcn);
  277.  
  278.     /* get the expression to look for and the association list */
  279.     x = xlgetarg();
  280.     alist = xlgalist();
  281.     xltest(&fcn,&tresult);
  282.  
  283.     /* look for the expression */
  284.     for (val = NIL; consp(alist); alist = cdr(alist))
  285.     if ((pair = car(alist)) && consp(pair))
  286.         if (dotest2(x,car(pair),fcn) == tresult) {
  287.         val = pair;
  288.         break;
  289.         }
  290.  
  291.     /* restore the stack */
  292.     xlpop();
  293.  
  294.     /* return result */
  295.     return (val);
  296. }
  297.  
  298. /* xsubst - substitute one expression for another */
  299. LVAL xsubst()
  300. {
  301.     LVAL to,from,expr,fcn,val;
  302.     int tresult;
  303.  
  304.     /* protect some pointers */
  305.     xlsave1(fcn);
  306.  
  307.     /* get the to value, the from value and the expression */
  308.     to = xlgetarg();
  309.     from = xlgetarg();
  310.     expr = xlgetarg();
  311.     xltest(&fcn,&tresult);
  312.  
  313.     /* do the substitution */
  314.     val = subst(to,from,expr,fcn,tresult);
  315.  
  316.     /* restore the stack */
  317.     xlpop();
  318.  
  319.     /* return the result */
  320.     return (val);
  321. }
  322.  
  323. /* subst - substitute one expression for another */
  324. LOCAL LVAL subst(to,from,expr,fcn,tresult)
  325.   LVAL to,from,expr,fcn; int tresult;
  326. {
  327.     LVAL carval,cdrval;
  328.  
  329.     if (dotest2(expr,from,fcn) == tresult)
  330.     return (to);
  331.     else if (consp(expr)) {
  332.     xlsave1(carval);
  333.     carval = subst(to,from,car(expr),fcn,tresult);
  334.     cdrval = subst(to,from,cdr(expr),fcn,tresult);
  335.     xlpop();
  336.     return (cons(carval,cdrval));
  337.     }
  338.     else
  339.     return (expr);
  340. }
  341.  
  342. /* xsublis - substitute using an association list */
  343. LVAL xsublis()
  344. {
  345.     LVAL alist,expr,fcn,val;
  346.     int tresult;
  347.  
  348.     /* protect some pointers */
  349.     xlsave1(fcn);
  350.  
  351.     /* get the assocation list and the expression */
  352.     alist = xlgalist();
  353.     expr = xlgetarg();
  354.     xltest(&fcn,&tresult);
  355.  
  356.     /* do the substitution */
  357.     val = sublis(alist,expr,fcn,tresult);
  358.  
  359.     /* restore the stack */
  360.     xlpop();
  361.  
  362.     /* return the result */
  363.     return (val);
  364. }
  365.  
  366. /* sublis - substitute using an association list */
  367. LOCAL LVAL sublis(alist,expr,fcn,tresult)
  368.   LVAL alist,expr,fcn; int tresult;
  369. {
  370.     LVAL carval,cdrval,pair;
  371.  
  372.     if (pair = assoc(expr,alist,fcn,tresult))
  373.     return (cdr(pair));
  374.     else if (consp(expr)) {
  375.     xlsave1(carval);
  376.     carval = sublis(alist,car(expr),fcn,tresult);
  377.     cdrval = sublis(alist,cdr(expr),fcn,tresult);
  378.     xlpop();
  379.     return (cons(carval,cdrval));
  380.     }
  381.     else
  382.     return (expr);
  383. }
  384.  
  385. /* assoc - find a pair in an association list */
  386. LOCAL LVAL assoc(expr,alist,fcn,tresult)
  387.   LVAL expr,alist,fcn; int tresult;
  388. {
  389.     LVAL pair;
  390.  
  391.     for (; consp(alist); alist = cdr(alist))
  392.     if ((pair = car(alist)) && consp(pair))
  393.         if (dotest2(expr,car(pair),fcn) == tresult)
  394.         return (pair);
  395.     return (NIL);
  396. }
  397.  
  398. /* xremove - built-in function 'remove' */
  399. LVAL xremove()
  400. {
  401.     LVAL x,list,fcn,val,last,next;
  402.     int tresult;
  403.  
  404.     /* protect some pointers */
  405.     xlstkcheck(2);
  406.     xlsave(fcn);
  407.     xlsave(val);
  408.  
  409.     /* get the expression to remove and the list */
  410.     x = xlgetarg();
  411.     list = xlgalist();
  412.     xltest(&fcn,&tresult);
  413.  
  414.     /* remove matches */
  415.     for (; consp(list); list = cdr(list))
  416.  
  417.     /* check to see if this element should be deleted */
  418.     if (dotest2(x,car(list),fcn) != tresult) {
  419.         next = consa(car(list));
  420.         if (val) rplacd(last,next);
  421.         else val = next;
  422.         last = next;
  423.     }
  424.  
  425.     /* restore the stack */
  426.     xlpopn(2);
  427.  
  428.     /* return the updated list */
  429.     return (val);
  430. }
  431.  
  432. /* xremif - built-in function 'remove-if' */
  433. LVAL xremif()
  434. {
  435.     LVAL remif();
  436.     return (remif(TRUE));
  437. }
  438.  
  439. /* xremifnot - built-in function 'remove-if-not' */
  440. LVAL xremifnot()
  441. {
  442.     LVAL remif();
  443.     return (remif(FALSE));
  444. }
  445.  
  446. /* remif - common code for 'remove-if' and 'remove-if-not' */
  447. LOCAL LVAL remif(tresult)
  448.   int tresult;
  449. {
  450.     LVAL list,fcn,val,last,next;
  451.  
  452.     /* protect some pointers */
  453.     xlstkcheck(2);
  454.     xlsave(fcn);
  455.     xlsave(val);
  456.  
  457.     /* get the expression to remove and the list */
  458.     fcn = xlgetarg();
  459.     list = xlgalist();
  460.     xllastarg();
  461.  
  462.     /* remove matches */
  463.     for (; consp(list); list = cdr(list))
  464.  
  465.     /* check to see if this element should be deleted */
  466.     if (dotest1(car(list),fcn) != tresult) {
  467.         next = consa(car(list));
  468.         if (val) rplacd(last,next);
  469.         else val = next;
  470.         last = next;
  471.     }
  472.  
  473.     /* restore the stack */
  474.     xlpopn(2);
  475.  
  476.     /* return the updated list */
  477.     return (val);
  478. }
  479.  
  480. /* dotest1 - call a test function with one argument */
  481. int dotest1(arg,fun)
  482.   LVAL arg,fun;
  483. {
  484.     LVAL *newfp;
  485.  
  486.     /* create the new call frame */
  487.     newfp = xlsp;
  488.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  489.     pusharg(fun);
  490.     pusharg(cvfixnum((FIXTYPE)1));
  491.     pusharg(arg);
  492.     xlfp = newfp;
  493.  
  494.     /* return the result of applying the test function */
  495.     return (xlapply(1) != NIL);
  496.  
  497. }
  498.  
  499. /* dotest2 - call a test function with two arguments */
  500. int dotest2(arg1,arg2,fun)
  501.   LVAL arg1,arg2,fun;
  502. {
  503.     LVAL *newfp;
  504.  
  505.     /* create the new call frame */
  506.     newfp = xlsp;
  507.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  508.     pusharg(fun);
  509.     pusharg(cvfixnum((FIXTYPE)2));
  510.     pusharg(arg1);
  511.     pusharg(arg2);
  512.     xlfp = newfp;
  513.  
  514.     /* return the result of applying the test function */
  515.     return (xlapply(2) != NIL);
  516.  
  517. }
  518.  
  519. /* xnth - return the nth element of a list */
  520. LVAL xnth()
  521. {
  522.     return (nth(TRUE));
  523. }
  524.  
  525. /* xnthcdr - return the nth cdr of a list */
  526. LVAL xnthcdr()
  527. {
  528.     return (nth(FALSE));
  529. }
  530.  
  531. /* nth - internal nth function */
  532. LOCAL LVAL nth(carflag)
  533.   int carflag;
  534. {
  535.     LVAL list,num;
  536.     FIXTYPE n;
  537.  
  538.     /* get n and the list */
  539.     num = xlgafixnum();
  540.     list = xlgacons();
  541.     xllastarg();
  542.  
  543.     /* make sure the number isn't negative */
  544.     if ((n = getfixnum(num)) < 0)
  545.     xlfail("bad argument");
  546.  
  547.     /* find the nth element */
  548.     while (consp(list) && --n >= 0)
  549.     list = cdr(list);
  550.  
  551.     /* return the list beginning at the nth element */
  552.     return (carflag && consp(list) ? car(list) : list);
  553. }
  554.  
  555. /* xlength - return the length of a list or string */
  556. LVAL xlength()
  557. {
  558.     FIXTYPE n;
  559.     LVAL arg;
  560.  
  561.     /* get the list or string */
  562.     arg = xlgetarg();
  563.     xllastarg();
  564.  
  565.     /* find the length of a list */
  566.     if (listp(arg))
  567.     for (n = 0; consp(arg); n++)
  568.         arg = cdr(arg);
  569.  
  570.     /* find the length of a string */
  571.     else if (stringp(arg))
  572.     n = (FIXTYPE)getslength(arg)-1;
  573.  
  574.     /* find the length of a vector */
  575.     else if (vectorp(arg))
  576.     n = (FIXTYPE)getsize(arg);
  577.  
  578.     /* otherwise, bad argument type */
  579.     else
  580.     xlerror("bad argument type",arg);
  581.  
  582.     /* return the length */
  583.     return (cvfixnum(n));
  584. }
  585.  
  586. /* xmapc - built-in function 'mapc' */
  587. LVAL xmapc()
  588. {
  589.     return (map(TRUE,FALSE));
  590. }
  591.  
  592. /* xmapcar - built-in function 'mapcar' */
  593. LVAL xmapcar()
  594. {
  595.     return (map(TRUE,TRUE));
  596. }
  597.  
  598. /* xmapl - built-in function 'mapl' */
  599. LVAL xmapl()
  600. {
  601.     return (map(FALSE,FALSE));
  602. }
  603.  
  604. /* xmaplist - built-in function 'maplist' */
  605. LVAL xmaplist()
  606. {
  607.     return (map(FALSE,TRUE));
  608. }
  609.  
  610. /* map - internal mapping function */
  611. LOCAL LVAL map(carflag,valflag)
  612.   int carflag,valflag;
  613. {
  614.     LVAL *newfp,fun,lists,val,last,p,x,y;
  615.     int argc;
  616.  
  617.     /* protect some pointers */
  618.     xlstkcheck(3);
  619.     xlsave(fun);
  620.     xlsave(lists);
  621.     xlsave(val);
  622.  
  623.     /* get the function to apply and the first list */
  624.     fun = xlgetarg();
  625.     lists = xlgalist();
  626.  
  627.     /* initialize the result list */
  628.     val = (valflag ? NIL : lists);
  629.  
  630.     /* build a list of argument lists */
  631.     for (lists = last = consa(lists); moreargs(); last = cdr(last))
  632.     rplacd(last,cons(xlgalist(),NIL));
  633.  
  634.     /* loop through each of the argument lists */
  635.     for (;;) {
  636.  
  637.     /* build an argument list from the sublists */
  638.     newfp = xlsp;
  639.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  640.     pusharg(fun);
  641.     pusharg(NIL);
  642.     argc = 0;
  643.     for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
  644.         pusharg(carflag ? car(y) : y);
  645.         rplaca(x,cdr(y));
  646.         ++argc;
  647.     }
  648.  
  649.     /* quit if any of the lists were empty */
  650.     if (x) {
  651.         xlsp = newfp;
  652.         break;
  653.     }
  654.  
  655.     /* apply the function to the arguments */
  656.     newfp[2] = cvfixnum((FIXTYPE)argc);
  657.     xlfp = newfp;
  658.     if (valflag) {
  659.         p = consa(xlapply(argc));
  660.         if (val) rplacd(last,p);
  661.         else val = p;
  662.         last = p;
  663.     }
  664.     else
  665.         xlapply(argc);
  666.     }
  667.  
  668.     /* restore the stack */
  669.     xlpopn(3);
  670.  
  671.     /* return the last test expression value */
  672.     return (val);
  673. }
  674.  
  675. /* xrplca - replace the car of a list node */
  676. LVAL xrplca()
  677. {
  678.     LVAL list,newcar;
  679.  
  680.     /* get the list and the new car */
  681.     list = xlgacons();
  682.     newcar = xlgetarg();
  683.     xllastarg();
  684.  
  685.     /* replace the car */
  686.     rplaca(list,newcar);
  687.  
  688.     /* return the list node that was modified */
  689.     return (list);
  690. }
  691.  
  692. /* xrplcd - replace the cdr of a list node */
  693. LVAL xrplcd()
  694. {
  695.     LVAL list,newcdr;
  696.  
  697.     /* get the list and the new cdr */
  698.     list = xlgacons();
  699.     newcdr = xlgetarg();
  700.     xllastarg();
  701.  
  702.     /* replace the cdr */
  703.     rplacd(list,newcdr);
  704.  
  705.     /* return the list node that was modified */
  706.     return (list);
  707. }
  708.  
  709. /* xnconc - destructively append lists */
  710. LVAL xnconc()
  711. {
  712.     LVAL next,last,val;
  713.  
  714.     /* initialize */
  715.     val = NIL;
  716.     
  717.     /* concatenate each argument */
  718.     if (moreargs()) {
  719.     while (xlargc > 1) {
  720.  
  721.         /* ignore everything except lists */
  722.         if ((next = nextarg()) && consp(next)) {
  723.  
  724.         /* concatenate this list to the result list */
  725.         if (val) rplacd(last,next);
  726.         else val = next;
  727.  
  728.         /* find the end of the list */
  729.         while (consp(cdr(next)))
  730.             next = cdr(next);
  731.         last = next;
  732.         }
  733.     }
  734.  
  735.     /* handle the last argument */
  736.     if (val) rplacd(last,nextarg());
  737.     else val = nextarg();
  738.     }
  739.  
  740.     /* return the list */
  741.     return (val);
  742. }
  743.  
  744. /* xdelete - built-in function 'delete' */
  745. LVAL xdelete()
  746. {
  747.     LVAL x,list,fcn,last,val;
  748.     int tresult;
  749.  
  750.     /* protect some pointers */
  751.     xlsave1(fcn);
  752.  
  753.     /* get the expression to delete and the list */
  754.     x = xlgetarg();
  755.     list = xlgalist();
  756.     xltest(&fcn,&tresult);
  757.  
  758.     /* delete leading matches */
  759.     while (consp(list)) {
  760.     if (dotest2(x,car(list),fcn) != tresult)
  761.         break;
  762.     list = cdr(list);
  763.     }
  764.     val = last = list;
  765.  
  766.     /* delete embedded matches */
  767.     if (consp(list)) {
  768.  
  769.     /* skip the first non-matching element */
  770.     list = cdr(list);
  771.  
  772.     /* look for embedded matches */
  773.     while (consp(list)) {
  774.  
  775.         /* check to see if this element should be deleted */
  776.         if (dotest2(x,car(list),fcn) == tresult)
  777.         rplacd(last,cdr(list));
  778.         else
  779.         last = list;
  780.  
  781.         /* move to the next element */
  782.         list = cdr(list);
  783.      }
  784.     }
  785.  
  786.     /* restore the stack */
  787.     xlpop();
  788.  
  789.     /* return the updated list */
  790.     return (val);
  791. }
  792.  
  793. /* xdelif - built-in function 'delete-if' */
  794. LVAL xdelif()
  795. {
  796.     LVAL delif();
  797.     return (delif(TRUE));
  798. }
  799.  
  800. /* xdelifnot - built-in function 'delete-if-not' */
  801. LVAL xdelifnot()
  802. {
  803.     LVAL delif();
  804.     return (delif(FALSE));
  805. }
  806.  
  807. /* delif - common routine for 'delete-if' and 'delete-if-not' */
  808. LOCAL LVAL delif(tresult)
  809.   int tresult;
  810. {
  811.     LVAL list,fcn,last,val;
  812.  
  813.     /* protect some pointers */
  814.     xlsave1(fcn);
  815.  
  816.     /* get the expression to delete and the list */
  817.     fcn = xlgetarg();
  818.     list = xlgalist();
  819.     xllastarg();
  820.  
  821.     /* delete leading matches */
  822.     while (consp(list)) {
  823.     if (dotest1(car(list),fcn) != tresult)
  824.         break;
  825.     list = cdr(list);
  826.     }
  827.     val = last = list;
  828.  
  829.     /* delete embedded matches */
  830.     if (consp(list)) {
  831.  
  832.     /* skip the first non-matching element */
  833.     list = cdr(list);
  834.  
  835.     /* look for embedded matches */
  836.     while (consp(list)) {
  837.  
  838.         /* check to see if this element should be deleted */
  839.         if (dotest1(car(list),fcn) == tresult)
  840.         rplacd(last,cdr(list));
  841.         else
  842.         last = list;
  843.  
  844.         /* move to the next element */
  845.         list = cdr(list);
  846.      }
  847.     }
  848.  
  849.     /* restore the stack */
  850.     xlpop();
  851.  
  852.     /* return the updated list */
  853.     return (val);
  854. }
  855.  
  856. /* xsort - built-in function 'sort' */
  857. LVAL xsort()
  858. {
  859.     LVAL sortlist();
  860.     LVAL list,fcn;
  861.  
  862.     /* protect some pointers */
  863.     xlstkcheck(2);
  864.     xlsave(list);
  865.     xlsave(fcn);
  866.  
  867.     /* get the list to sort and the comparison function */
  868.     list = xlgalist();
  869.     fcn = xlgetarg();
  870.     xllastarg();
  871.  
  872.     /* sort the list */
  873.     list = sortlist(list,fcn);
  874.  
  875.     /* restore the stack and return the sorted list */
  876.     xlpopn(2);
  877.     return (list);
  878. }
  879.  
  880. /*
  881.     This sorting algorithm is based on a Modula-2 sort written by
  882.     Richie Bielak and published in the February 1988 issue of
  883.     "Computer Language" magazine in a letter to the editor.
  884. */
  885.  
  886. /* sortlist - sort a list using quicksort */
  887. LOCAL LVAL sortlist(list,fcn)
  888.   LVAL list,fcn;
  889. {
  890.     LVAL gluelists();
  891.     LVAL smaller,pivot,larger;
  892.     
  893.     /* protect some pointers */
  894.     xlstkcheck(3);
  895.     xlsave(smaller);
  896.     xlsave(pivot);
  897.     xlsave(larger);
  898.     
  899.     /* lists with zero or one element are already sorted */
  900.     if (consp(list) && consp(cdr(list))) {
  901.     pivot = list; list = cdr(list);
  902.     splitlist(pivot,list,&smaller,&larger,fcn);
  903.     smaller = sortlist(smaller,fcn);
  904.     larger = sortlist(larger,fcn);
  905.     list = gluelists(smaller,pivot,larger);
  906.     }
  907.  
  908.     /* cleanup the stack and return the sorted list */
  909.     xlpopn(3);
  910.     return (list);
  911. }
  912.  
  913. /* splitlist - split the list around the pivot */
  914. LOCAL splitlist(pivot,list,psmaller,plarger,fcn)
  915.   LVAL pivot,list,*psmaller,*plarger,fcn;
  916. {
  917.     LVAL next;
  918.     
  919.     /* initialize the result lists */
  920.     *psmaller = *plarger = NIL;
  921.     
  922.     /* split the list */
  923.     for (; consp(list); list = next) {
  924.     next = cdr(list);
  925.     if (dotest2(car(list),car(pivot),fcn)) {
  926.         rplacd(list,*psmaller);
  927.         *psmaller = list;
  928.     }
  929.     else {
  930.         rplacd(list,*plarger);
  931.         *plarger = list;
  932.     }
  933.     }
  934. }
  935.  
  936. /* gluelists - glue the smaller and larger lists with the pivot */
  937. LOCAL LVAL gluelists(smaller,pivot,larger)
  938.   LVAL smaller,pivot,larger;
  939. {
  940.     LVAL last;
  941.     
  942.     /* larger always goes after the pivot */
  943.     rplacd(pivot,larger);
  944.  
  945.     /* if the smaller list is empty, we're done */
  946.     if (null(smaller))
  947.     return (pivot);
  948.  
  949.     /* append the smaller to the front of the resulting list */
  950.     for (last = smaller; consp(cdr(last)); last = cdr(last))
  951.     ;
  952.     rplacd(last,pivot);
  953.     return (smaller);
  954. }
  955.